home *** CD-ROM | disk | FTP | other *** search
/ Programmer Power Tools / Programmer Power Tools.iso / filutl / ldiff12s.arc / KERR.PAS next >
Encoding:
Pascal/Delphi Source File  |  1989-07-15  |  1.9 KB  |  82 lines
  1. (*$B-,F-,I-,N-*)
  2. (*---------------------------------------------------------------------------*)
  3. (*                                                                           *)
  4. (*                    KERR - Err unit for Turbo Pascal 4.0                   *)
  5. (*                                                                           *)
  6. (*                      Copyright(c) 1988  Jun Katsumata                     *)
  7. (*                                                                           *)
  8. (*       ver1.00  1988/02/22                                                 *)
  9. (*       ver1.01  1988/02/25  append é╔æ╬ë₧é╡é─éóé╚é⌐é┴é╜é▒é╞é≡É[é¡ö╜Å╚      *)
  10. (*       ver1.02  1988/05/05  Äßè▒é╠ÄΦÆ╝é╡ by Kazuhiko Miki                  *)
  11. (*---------------------------------------------------------------------------*)
  12. unit kerr;
  13.  
  14.  
  15. interface
  16.  
  17.  
  18. uses dos;
  19.  
  20.  
  21. procedure assignerr(var f:text);
  22.  
  23.  
  24. implementation
  25.  
  26.  
  27. const
  28.    stderr = 2;
  29. var
  30.    regs : registers;
  31.  
  32.  
  33. {$f+}
  34. function erroutput(var f:textrec):integer;
  35. begin
  36.    with regs,f do begin
  37.       ah:=$40;
  38.       bx:=stderr;
  39.       cx:=bufpos;
  40.       ds:=seg(bufptr^);
  41.       dx:=ofs(bufptr^);
  42.       msdos(regs);
  43.       if ax=bufpos
  44.          then erroutput:=0
  45.          else erroutput:=101;  { disk write error }
  46.       bufpos:=0;
  47.    end;
  48. end;
  49.  
  50.  
  51. function erropen(var f:textrec):integer;
  52. begin
  53.    with f do begin
  54.       if mode=fminput then
  55.          erropen:=5
  56.       else begin
  57.          mode:=fmoutput;
  58.          inoutfunc:=@erroutput;
  59.          flushfunc:=@erroutput;
  60.          closefunc:=@erroutput;
  61.          erropen:=0;
  62.       end;
  63.    end;
  64. end;
  65. {$f-}
  66.  
  67.  
  68. procedure assignerr(var f:text);
  69. begin
  70.    with textrec(f) do begin
  71.       handle  :=$ffff;
  72.       mode    :=fmclosed;
  73.       bufsize :=sizeof(buffer);
  74.       bufptr  :=@buffer;
  75.       openfunc:=@erropen;
  76.       name[0] :=#0;
  77.     end;
  78. end;
  79.  
  80.  
  81. end.
  82.